Celestin Apprentice 4

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / More classes / MW documents / MW3⁄4ut < prev next >

Wrap

Text File | 1990-03-01 | 13.7 KB | 584 lines | [TEXT/MSET]

\ Utility routines etc. for Word 3.0 documents. 0 value BUF_START 0 value STLS \ Holds copy of styles byte of current format 0 value OPTIONS \ Holds copy of options byte 0 value DOING_PARAS? \ The following words handle the "change information" that is present if \ the document was saved using "Fast save". This is fairly complicated, \ so we hope we've got it right. If we don't recognize something, we set \ MYSTERY? true and put the code we didn't recognize into UNPROCESSED_CODE, \ so the application can warn the user that there may be problems. These \ problems may be insignificant, which is why we don't give a hard error. 0 value #CHANGES 0 value OPCODE \ Holds op code for style etc. override 0 value OVERRIDE_MARKER 0 value NEW_CHANGE_BLK? 0 value FMT_STRT 0 value CHG-BLK? 0 value CHGD-BLK? \ True if previous offset was in a new chg blk 0 value OV_BLK# false value OV_ON? \ ============== Setting up ================ : LOCATE_NEW_CHANGE { offs -- } reset: changes BEGIN len: changes 0EXIT offs ^1st: changes @ < ?EXIT 14 skip: changes AGAIN ; local FIX_OVERRIDE { \ this_dst -- } : SETUP_OFFSETS true -> ov_on? \ Forces generation of a fmt_ov_run entry to \ turn overrides off at the start tmp dup copyto: src copyto: dst len: tmp 2/ 2/ 1- 3 / -> #changes #changes 1+ 4* skip: src 4 nxtn: dst -> this_dst #changes 0 ?DO pause 2 skip: src 4 nxtn: src hdr_len - \ source offset - save dup locate_new_change 2 nxtn: src -> override_marker ( this_dst ) fix_override \ Note: uses PAD pad ! \ source offset to PAD 4 nxtn: dst dup this_dst - pad 4+ ! \ length this_dst pad 8 + ! \ dest offset -> this_dst override_marker pad 12 + w! \ override marker pad 14 insert: changes \ Move new entry in from PAD LOOP ; : SU_STYL_OV nxtc: tmp dup $ 80 <> and \ 0 or $ 80 mean off, anything else means 0<> negate \ on ... I hope ... opcode $ 1E - ^1st: fmt_ov_str + c! ; : SU_FONT_OV 2 nxtn: tmp ^1st: fmt_ov_str 10 + w! ; : SU_SIZ_OV nxtc: tmp 2/ ^1st: fmt_ov_str 9 + c! ; : SU_UND_OV nxtc: tmp 2* ^1st: fmt_ov_str 8 + c! ; : SU_VD_OV nxtc: tmp dup $ 80 = IF drop 0 THEN ^1st: fmt_ov_str 12 + c! ; : SU_HD_OV nxtc: tmp $ 40 - 2* 2* ^1st: fmt_ov_str 13 + c! ; : SU_PARA_OV1 1 skip: tmp ; \ opcode 5 = \ IF nxtc: tmp ^1st: para_ov_str w! \ ELSE 1 skip: tmp \ We're not handling these others \ THEN ; : SU_PARA_OV2 2 skip: tmp ; \ 2 nxtn: tmp \ opcode dup $ 13 >= - $ E - 2* ^1st: para_ov_str + w! ; : SU_STYL#_OV nxtc: tmp ^1st: para_ov_str ( 2+ ) w! ; : SU_OUTL_OV nxtc: tmp 2+ \ outlining level no. 1 max 9 min \ just in case negate $ FF and ^1st: para_ov_str ( 2+ ) w! ; : SU_SECT_OV this_dst +L: sect_ov_str nxtc: tmp +W: sect_ov_str ; : SETUP_1_OVERRIDE nxtc: tmp dup -> opcode CASE[ $ 1E $ 25 RANGE]=> su_styl_ov [ $ 05 $ 0B RANGE]=> su_para_ov1 [ $ 10 $ 15 RANGE]=> su_para_ov2 [ $ 02 ]=> su_styl#_ov [ $ 04 ]=> su_outl_ov [ $ 0F ]=> ( tabs - we're ignoring them ) nxtc: tmp ( length ) skip: tmp [ $ 26 ]=> su_font_ov [ $ 27 ], [ $ 45 ]=> su_und_ov \ The 45 can come in W4 docs [ $ 28 ]=> su_siz_ov [ 0 ]=> su_VD_ov [ $ 29 ]=> su_HD_ov [ $ 41 ]=> su_sect_ov [ $ 1D ]=> ( pass - do nothing) DEFAULT=> \ This means an opcode we don't know anything about. \ So we set MYSTERY? and skip to the end of the field. -> unprocessed_code true -> mystery? lim: tmp >pos: tmp ]CASE ; : SETUP_OVERRIDES pause 1 ++> ov_blk# end: fmt_ov_str pos: fmt_ov_str pad infoSize: fmt_run 2dup 128 fill add: fmt_ov_str \ set all fields to "leave" initially >pos: fmt_ov_str end: para_ov_str pos: para_ov_str pad infoSize: para_run 2dup bounds DO $ 8000 i w! 2 +LOOP add: para_ov_str >pos: para_ov_str BEGIN len: tmp 1 > WHILE setup_1_override REPEAT ; : TURN_OV_OFF \ ( dest -- ) false -> ov_on? pad ! pad 4+ infoSize: fmt_run 128 fill pad itemSize: fmt_run add: fmt_ov_run ; :loc FIX_OVERRIDE override_marker ov_on? or 0EXIT \ Out if we don't need an \ override entry here override_marker NIF this_dst turn_ov_off EXIT THEN true -> ov_on? override_marker $ 8000 and NIF \ It's immediate - create new ov str entries and make indirect. save: tmp src copyto: tmp -2 skip: tmp 2 >len: tmp setup_overrides \ Actually, there's only 1 restore: tmp ov_blk# 1- $ 8000 or -> override_marker THEN \ Now put new entry into FMT_OV_RUN this_dst +L: fmt_ov_run infoSize: fmt_run dup override_marker $ 7FFF and * >pos: fmt_ov_str >len: fmt_ov_str fmt_ov_str $add: fmt_ov_run ;loc : SETUP_CHANGE \ ( code -- ) CASE[ 1 ]=> setup_overrides [ 2 ]=> setup_offsets DEFAULT=> -> unprocessed_code true -> mystery? ]CASE lim: tmp >pos: tmp ; \ ======= Applying the changes ======= : EXTEND_TEXT \ Yes, this can happen, if changes insert stuff! \ pos: text real_text_len <= \ IF \ Extending at or before the end. Adjust real_text_len \ len: theFile len: text - ++> real_text_len \ THEN pos: text dup len: theFile + \ Desired length setsize: text >pos: text ; : CHANGE_TEXT reset: text reset: changes 0 -> text&hf_len #changes 0 ?DO nxtL: changes >pos: theFile nxtL: changes >len: theFile nxtL: changes >pos: text len: theFile len: text > IF extend_text THEN theFile $ovwr: text pos: text text&hf_len max -> text&hf_len 2 skip: changes ( we don't use the override marker here ) LOOP real_text_len text&hf_len max setsize: text ; : FIND_OV_POSN override_marker ?dup 0EXIT $ 7FFF and infoSize: para_run * >pos: para_ov_str ; : FIND_PLACE { offs -- } BEGIN len: changes 0EXIT offs ^1st: changes @ ^1st: changes 4+ @ + \ doing_paras? IF <= ELSE < THEN <= ?EXIT 14 skip: changes AGAIN ; : DIFFERENT_CHANGE_BLK { offs -- } offs find_place len: changes IF ^1st: changes 12 + w@ -> override_marker find_ov_posn ELSE 0 -> override_marker THEN ; : CHANGE_OFFSET { offs -- offs' } \ Returns -1 if offs is outside limits. chg-blk? -> chgd-blk? fast? NIF offs EXIT THEN len: changes NIF -1 EXIT THEN offs ^1st: changes @ ^1st: changes 4+ @ + \ doing_paras? IF > ELSE >= THEN > dup -> chg-blk? IF offs different_change_blk len: changes NIF -1 EXIT THEN THEN offs ^1st: changes @ - 0 max \ Coerce font change rightward \ after a deletion ^1st: changes 8 + @ + ; \ Return transformed offset : ?DO_PARA_OVERRIDE \ Note: para_run POS is at the start of the \ styles field. override_marker 0EXIT ^1st: para_ov_str w@ dup $ 8000 <> IF ^1st: para_run w! ELSE drop THEN ; \ pos: para_run \ infoSize: para_run 0 DO \ ^1st: para_ov_str i + w@ dup $ 8000 <> \ IF >nxtw: para_run ELSE drop 2 skip: para_run THEN \ 2 +LOOP \ >pos: para_run ; \ ======= Miscellaneous useful words ======= : SETUP_BLKS \ ( -- #blks ) theFile copyto: dst len: dst 4- 6 / ( # blks ) dup 1+ 4* skip: dst reset: changes false -> chg-blk? false -> chgd-blk? ; : NEXT_OFFS { \ offs -- offs } save_offs -> offs unmpd_new -> unmpd_old nxtl: buf hdr_len - dup -> unmpd_new change_offset -> save_offs doing_paras? NIF offs EXIT THEN \ For paras, we have to make sure that the incoming para offsets correspond \ to the RET chars in the text, since changes might have deleted or inserted \ extra RETs. We do this here. What this amounts to is that we have to find \ the RET which begins the para immediately before where SAVE_OFFS points. \ We return the offs of this para (i.e. the offs of RET plus 1). start: text save_offs 1 max >lim: text -1 more: text RET <chsearch: text pos: text + ; \ If RET found, skip it : NEXT_ITEM? \ ( -- offs T | F ) next_offs chgd-blk? IF dup true doing_paras? IF find_posn: para_run ELSE find_posn: fmt_run THEN THEN ( offs ) dup 0>= dup NIF nip 1 skip: buf_offsets THEN ; \ ======== Merging formats ======== \ This isn't fun!! : MERGE1 { offs -- } offs +L: fmt_run pos: src ( save ) 4 skip: src infoSize: fmt_run >len: src pos: fmt_run src $add: fmt_run >pos: fmt_run >pos: src nolim: src 4 skip: fmt_ov_run infoSize: fmt_run 0 DO ^1st: fmt_ov_run i + c@ dup 128 <> IF >nxtc: fmt_run ELSE drop 1 skip: fmt_run THEN LOOP ^1st: fmt_ov_run 10 + c@ 128 <> IF ( kludge to make sure font# 128 works ) ^1st: fmt_ov_run 11 + c@ ^1st: fmt_run 3 - c! THEN -4 skip: fmt_ov_run ; 0 value PREV \ Holds offset in SRC of last entry read \ -- this is the one currently in effect : DO_LIMIT { limit -- } \ Generates new fmt_run entry for override \ change at the limit skip_item: fmt_ov_run prev 0< IF \ No SRC entry valid yet. Just copy ov entry over itemSize: fmt_run >len: fmt_ov_run fmt_ov_run $add: fmt_run nolim: fmt_ov_run ELSE prev swappos: src limit merge1 <skip_item: fmt_ov_run >pos: src THEN ; : MERGE_TO_LIMIT { limit \ src-offs done? do-lim? -- } false -> done? false -> do-lim? BEGIN len: src IF ^1st: src @ -> src-offs src-offs limit 2dup > -> do-lim? >= -> done? ELSE \ No formats left. We may, however, have to generate a \ fmt_run entry for the limit. We only need to do this \ if it is a "real" (not a dummy) limit. limit big# <> -> do-lim? true -> done? THEN do-lim? IF limit do_limit EXIT THEN done? ?EXIT src-offs merge1 pos: src -> prev skip_item: src AGAIN ; : (MERGE_FMTS) -1 -> prev ( means not valid yet ) BEGIN pause len: fmt_ov_run NIF ( no more overrides left - copy rest of src over ) src $add: fmt_run EXIT THEN len: src NIF <skip_item: src BEGIN len: fmt_ov_run 0EXIT ^1st: fmt_ov_run @ merge1 skip_item: fmt_ov_run AGAIN THEN len: fmt_ov_run itemSize: fmt_ov_run > IF ^1st: fmt_ov_run itemSize: fmt_ov_run + @ ELSE big# THEN merge_to_limit skip_item: fmt_ov_run AGAIN ; : MERGE_FMTS fast? 0EXIT reset: fmt_ov_run len: fmt_ov_run 0EXIT \ Out if nothing to merge fmt_run copyto: src reset: src new: fmt_run (merge_fmts) \ Do it release: src ; \ ======= Style sheet operations ======= \ The string of style names has the level names first, in reverse order, \ then any synonym(s) for "Normal" (empty if none), then the ordinary \ styles in forward order. scon NORM_STYLE "Normal" hex table DFLT_FONT 05001800 , dflt_font# c, 18 c, \ Default: Geneva 12 end_table table DFLT_PARA \ 07000000 , 0 , 03000000 , end_table decimal : SKIP1NAME \ is1st# 255 of> style_names 1st: style_names $ FF = IF 1 skip: style_names ELSE count: style_names step: style_names THEN ; : COUNT_STYLES reset: style_names 0 -> #styles BEGIN len: style_names WHILE skip1name 1 ++> #styles REPEAT ; : GET_STYLE_NAME { n \ cnt -- addr len } \ Exported. n NIF norm_style EXIT THEN reset: style_names #levels negate -> cnt BEGIN len: style_names NIF 0 0 EXIT THEN cnt n = IF \ is1st# 255 of> style_names IF 0 0 EXIT THEN 1st: style_names $ FF = IF 0 0 EXIT THEN count: style_names get: style_names EXIT THEN skip1name 1 ++> cnt AGAIN ; : GET_STYLE# { addr len \ n -- n } \ Exported. \ Maybe we should handle synonyms at some stage, if \ anyone wants it. addr len norm_style s= IF 0 EXIT THEN reset: style_names #levels negate -> n BEGIN len: style_names NIF \ Put new style name in len +: style_names addr len add: style_names 1 ++> #styles n EXIT THEN \ is1st# 255 of> style_names 1st: style_names $ FF = IF 1 skip: style_names ELSE count: style_names get: style_names addr len s= IF n EXIT THEN step: style_names THEN 1 ++> n AGAIN ; : DUMMY_LEVEL_INFO reset: style_names pad #levels 2dup -1 fill add: src #levels 0 ?DO skip1name LOOP ; : SS_FORMATS dummy_level_info \ Dummy formats dflt_font add: src \ Default format for Normal style skip1name \ Skip Normal name #styles #levels - 1 ?DO \ Put in dummy formats \ is1st# 255 of> style_names 1st: style_names $ FF = IF $ FF +c: src 1 skip: style_names ELSE 0 +c: src count: style_names step: style_names THEN LOOP reset: src len: src 2+ 2 +n: dst src $add: dst ; : SS_PARAS clear: src dummy_level_info #styles #levels - 0 ?DO \ is1st# 255 of> style_names 1st: style_names $ FF = IF $ FF +c: src 1 skip: style_names ELSE dflt_para add: src i ^1st: src 3 - c! count: style_names step: style_names THEN LOOP reset: src len: src 2+ 2 +n: dst src $add: dst ; : SETUP_STYLE_SHEET new: src new: dst size: style_names IF count_styles ELSE \ There must be at least a "normal" style, or Word will \ crash! So we'll put one in. 0 +c: style_names 1 -> #styles THEN reset: style_names #levels +W: dst len: style_names 2+ +W: dst style_names $add: dst ss_formats ss_paras #styles 2 +N: dst pad #levels 2* 2dup erase add: dst $ 00DE 2 +n: dst #styles #levels - 1- 0 ?DO 0 2 +n: dst LOOP reset: dst release: src ; : NEED_LEVEL { lev# \ n -- } \ Exported. Ensures that the number of levels we \ have is at least lev#. lev# #levels - -> n n 0<= ?EXIT start: style_names pad n 2dup -1 fill insert: style_names lev# -> #levels ; \ ============================== :class SD super( object ) var START int LENGTH :m GET: get: start get: length ;m :m PUT: put: length put: start ;m :m USE: get: self swap hdr_len - >pos: theFile >len: theFile ;m ;class variable STYLES -4 allot here hex 80 c, \ bold 40 c, \ italic 20 c, \ strikethru 10 c, \ outline 08 c, \ shadow 04 c, \ small caps 02 c, \ all caps 01 c, \ hidden decimal here swap - constant STYLES_LEN